home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / disk-cache-accessors.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  43.2 KB  |  1,207 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: ccl -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; disk-cache-accessors.lisp
  6. ;; low-level accessors for disk-cache's
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15. ;;
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;; Modification History
  20. ;;
  21. ;; ------------- 0.5
  22. ;; 07/23/92 bill array-data-and-offset -> lenient-array-data-and-offset
  23. ;;               length -> uvector-bytes
  24. ;;               These make the code that saves and restores non-array
  25. ;;               ivectors (e.g. bignums, ratios, complex numbers)
  26. ;;               work correctly.
  27. ;; 07/20/92 bill da -> da.l where necessary.
  28. ;; ------------  0.1
  29. ;; 05/30/92 bill read-string & fill-xxx now skip $block-overhead
  30. ;; 03/16/92 bill New file.
  31. ;;
  32.  
  33. (in-package :ccl)                       ; So LAP works easily
  34.  
  35. (export '(wood::read-long wood::read-unsigned-long
  36.           wood::read-string wood::read-pointer
  37.           wood::read-low-24-bits wood::read-8-bits
  38.           wood::fill-long wood::fill-word wood::fill-byte)
  39.         'wood)
  40.  
  41. (require :lapmacros)
  42. (require :lispequ)
  43.  
  44. (declaim (inline byte-array-p ensure-byte-array))
  45.  
  46. (defun byte-array-p (array)
  47.   (lap-inline ()
  48.     (:variable array)
  49.     (move.l (varg array) arg_y)
  50.     (move.l arg_y atemp0)
  51.     (move.l nilreg acc)
  52.     (if# (and (ne (dtagp arg_y $t_vector))
  53.               (or (eq (progn (move.b (atemp0 $v_subtype) da)
  54.                              (cmp.b ($ $v_sstr) da)))
  55.                   (eq (cmp.b ($ $v_ubytev) da))
  56.                   (eq (cmp.b ($ $v_sbytev) da))))
  57.       (add.l ($ $t_val) acc))))
  58.  
  59. (defun ensure-byte-array (array)
  60.   (unless (byte-array-p array)
  61.     (error "~s is not a byte array" array)))
  62.  
  63. (defun wood::read-long (disk-cache address)
  64.   (multiple-value-bind (array index count)
  65.                        (wood::get-disk-page disk-cache address)
  66.     (declare (fixnum index count))
  67.     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
  68.       (error "Address odd or past eof: ~s" address))
  69.     (lap-inline ()
  70.       (:variable array index)
  71.       (move.l (varg array) atemp0)
  72.       (move.l (varg index) da)
  73.       (getint da)
  74.       (move.l (atemp0 da $v_data) arg_z)
  75.       (jsr_subprim $sp-mklong))))
  76.  
  77. (defun wood::%load-long (array address)
  78.   (ensure-byte-array array)
  79.   (setq address (require-type address 'fixnum))
  80.   (locally (declare (fixnum address))
  81.     (unless (>= (the fixnum (length array))
  82.                 (the fixnum (+ address 4)))
  83.       (error "Attempt to read past end of buffer."))
  84.     (unless (eql 0 (the fixnum (logand 1 address)))
  85.       (error "Odd address: ~s" address))
  86.     (lap-inline ()
  87.       (:variable array address immediate?)
  88.       (move.l (varg array) atemp0)
  89.       (move.l (varg address) da)
  90.       (getint da)
  91.       (move.l (atemp0 da $v_data) arg_z)
  92.       (jsr_subprim $sp-mklong))))
  93.  
  94. (defun wood::read-unsigned-long (disk-cache address)
  95.   (multiple-value-bind (array index count)
  96.                        (wood::get-disk-page disk-cache address)
  97.     (declare (fixnum index count))
  98.     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
  99.       (error "Address odd or past eof: ~s" address))
  100.     (lap-inline ()
  101.       (:variable array index)
  102.       (move.l (varg array) atemp0)
  103.       (move.l (varg index) da)
  104.       (getint da)
  105.       (move.l (atemp0 da $v_data) arg_z)
  106.       (jsr_subprim $sp-mkulong))))
  107.  
  108. (defun wood::%load-unsigned-long (array address)
  109.   (ensure-byte-array array)
  110.   (setq address (require-type address 'fixnum))
  111.   (locally (declare (fixnum address))
  112.     (unless (>= (the fixnum (length array))
  113.                 (the fixnum (+ address 4)))
  114.       (error "Attempt to read past end of buffer."))
  115.     (unless (eql 0 (the fixnum (logand 1 address)))
  116.       (error "Odd address: ~s" address))
  117.     (lap-inline ()
  118.       (:variable array address)
  119.       (move.l (varg array) atemp0)
  120.       (move.l (varg address) da)
  121.       (getint da)
  122.       (move.l (atemp0 da $v_data) arg_z)
  123.       (jsr_subprim $sp-mkulong))))
  124.  
  125. (defun (setf wood::read-long) (value disk-cache address)
  126.   (unless (>= (wood::disk-cache-size disk-cache)
  127.               (+ address 4))
  128.     (wood::extend-disk-cache disk-cache (+ address 4)))
  129.   (multiple-value-bind (array index count)
  130.                        (wood::get-disk-page disk-cache address t)
  131.     (declare (fixnum index count))
  132.     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
  133.       (error "Address odd or past eof: ~s" address))
  134.     (lap-inline ()
  135.       (:variable array index value)
  136.       (move.l (varg value) arg_z)
  137.       (jsr_subprim $sp-getxlong)
  138.       (move.l (varg array) atemp0)
  139.       (move.l (varg index) da)
  140.       (getint da)
  141.       (move.l acc (atemp0 da $v_data))))
  142.   value)
  143.  
  144. (defsetf wood::read-unsigned-long (disk-cache address) (value)
  145.   `(setf (wood::read-long ,disk-cache ,address) ,value))
  146.  
  147. (defun wood::%store-long (value array address)
  148.   (ensure-byte-array array)
  149.   (setq address (require-type address 'fixnum))
  150.   (locally (declare (fixnum address))
  151.     (unless (>= (the fixnum (length array))
  152.                 (the fixnum (+ address 4)))
  153.       (error "Attempt to write past end of buffer."))
  154.     (unless (eql 0 (the fixnum (logand 1 address)))
  155.       (error "Odd address: ~s" address))
  156.     (lap-inline ()
  157.       (:variable array address value)
  158.         (move.l (varg value) arg_z)
  159.         (jsr_subprim $sp-getxlong)
  160.         (move.l (varg array) atemp0)
  161.         (move.l (varg address) da)
  162.         (getint da)
  163.         (move.l acc (atemp0 da $v_data))))
  164.   value)
  165.  
  166. (defun wood::read-word (disk-cache address)
  167.   (multiple-value-bind (array index count)
  168.                        (wood::get-disk-page disk-cache address)
  169.     (declare (fixnum index count))
  170.     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
  171.       (error "Address odd or past eof: ~s" address))
  172.     (lap-inline ()
  173.       (:variable array index)
  174.       (move.l (varg array) atemp0)
  175.       (move.l (varg index) da)
  176.       (getint da)
  177.       (move.w (atemp0 da $v_data) acc)
  178.       (ext.l acc)
  179.       (mkint acc))))
  180.  
  181. (defun wood::%load-word (array address)
  182.   (ensure-byte-array array)
  183.   (setq address (require-type address 'fixnum))
  184.   (locally (declare (fixnum address))
  185.     (unless (>= (the fixnum (length array))
  186.                 (the fixnum (+ address 2)))
  187.       (error "Attempt to read past end of buffer."))
  188.     (unless (eql 0 (the fixnum (logand 1 address)))
  189.       (error "Odd address: ~s" address))
  190.     (lap-inline ()
  191.       (:variable array address)
  192.       (move.l (varg array) atemp0)
  193.       (move.l (varg address) da)
  194.       (getint da)
  195.       (move.w (atemp0 da $v_data) acc)
  196.       (ext.l acc)
  197.       (mkint acc))))
  198.  
  199. (defun wood::read-unsigned-word (disk-cache address)
  200.   (multiple-value-bind (array index count)
  201.                        (wood::get-disk-page disk-cache address)
  202.     (declare (fixnum index count))
  203.     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
  204.       (error "Address odd or past eof: ~s" address))
  205.     (lap-inline ()
  206.       (:variable array index)
  207.       (move.l (varg array) atemp0)
  208.       (move.l (varg index) da)
  209.       (getint da)
  210.       (move.l ($ 0) acc)
  211.       (move.w (atemp0 da $v_data) acc)
  212.       (mkint acc))))
  213.  
  214. (defun wood::%load-unsigned-word (array address)
  215.   (ensure-byte-array array)
  216.   (setq address (require-type address 'fixnum))
  217.   (locally (declare (fixnum address))
  218.     (unless (>= (the fixnum (length array))
  219.                 (the fixnum (+ address 2)))
  220.       (error "Attempt to read past end of buffer."))
  221.     (unless (eql 0 (the fixnum (logand 1 address)))
  222.       (error "Odd address: ~s" address))
  223.     (lap-inline ()
  224.       (:variable array address)
  225.       (move.l (varg array) atemp0)
  226.       (move.l (varg address) da)
  227.       (getint da)
  228.       (move.l ($ 0) acc)
  229.       (move.w (atemp0 da $v_data) acc)
  230.       (mkint acc))))
  231.  
  232. (defun (setf wood::read-word) (value disk-cache address)
  233.   (setq value (require-type value 'fixnum))
  234.   (unless (>= (wood::disk-cache-size disk-cache)
  235.               (+ address 4))
  236.     (wood::extend-disk-cache disk-cache (+ address 4)))
  237.   (multiple-value-bind (array index count)
  238.                        (wood::get-disk-page disk-cache address t)
  239.     (declare (fixnum index count))
  240.     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index))))
  241.       (error "Odd address: ~s" address))
  242.     (lap-inline ()
  243.       (:variable array index value)
  244.       (move.l (varg value) acc)
  245.       (getint acc)
  246.       (move.l (varg array) atemp0)
  247.       (move.l (varg index) da)
  248.       (getint da)
  249.       (move.w acc (atemp0 da $v_data))
  250.       (mkint acc))))
  251.  
  252. (defsetf wood::read-unsigned-word (disk-cache address) (value)
  253.   `(setf (wood::read-word ,disk-cache ,address) ,value))
  254.  
  255. (defun wood::%store-word (value array address)
  256.   (ensure-byte-array array)
  257.   (setq address (require-type address 'fixnum))
  258.   (locally (declare (fixnum address))
  259.     (unless (>= (the fixnum (length array))
  260.                 (the fixnum (+ address 2)))
  261.       (error "Attempt to read past end of buffer."))
  262.     (unless (eql 0 (the fixnum (logand 1 address)))
  263.       (error "Address not word aligned: ~s" address))
  264.     (lap-inline ()
  265.       (:variable value array address)
  266.       (move.l (varg array) atemp0)
  267.       (move.l (varg address) da)
  268.       (getint da)
  269.       (move.l (varg value) acc)
  270.       (getint acc)
  271.       (move.w acc (atemp0 da $v_data))
  272.       (mkint acc))))
  273.  
  274.  
  275. ; Avoid consing bignums by not boxing immediate data
  276. ; from the file.
  277. ; Second value is true if the result was immediate.
  278. (defun wood::read-pointer (disk-cache address)
  279.   (multiple-value-bind (array index count)
  280.                        (wood::get-disk-page disk-cache address)
  281.     (declare (fixnum index count))
  282.     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
  283.       (error "Address odd or past eof: ~s" address))
  284.     (let (immediate?)
  285.       (values
  286.        (lap-inline ()
  287.          (:variable array index immediate?)
  288.          (move.l (varg array) atemp0)
  289.          (move.l (varg index) da)
  290.          (getint da)
  291.          (move.l (atemp0 da $v_data) arg_z)
  292.          (if# (ne (dtagp arg_z $t_fixnum $t_imm $t_sfloat))
  293.            (movereg arg_z acc)
  294.            (move.l '1 (varg immediate?))
  295.            else#
  296.            (jsr_subprim $sp-mkulong)))
  297.        immediate?))))
  298.  
  299. ; load directly from a byte array.
  300. (defun wood::%load-pointer (array address)
  301.   (ensure-byte-array array)
  302.   (setq address (require-type address 'fixnum))
  303.   (locally (declare (fixnum address))
  304.     (unless (>= (the fixnum (length array))
  305.                 (the fixnum (+ address 4)))
  306.       (error "Attempt to read past end of buffer."))
  307.     (unless (eql 0 (the fixnum (logand 1 address)))
  308.       (error "Odd address: ~s" address))
  309.     (let (immediate?)
  310.       (values
  311.        (lap-inline ()
  312.          (:variable array address immediate?)
  313.          (move.l (varg array) atemp0)
  314.          (move.l (varg address) da)
  315.          (getint da)
  316.          (move.l (atemp0 da $v_data) arg_z)
  317.          (if# (ne (dtagp arg_z $t_fixnum $t_imm $t_sfloat))
  318.            (movereg arg_z acc)
  319.            (move.l '1 (varg immediate?))
  320.            else#
  321.            (jsr_subprim $sp-mkulong)))
  322.        immediate?))))
  323.  
  324. ; same as %load-pointer, but does no type checking
  325. (defun wood::%%load-pointer (array address)
  326.   (let (immediate?)
  327.     (values
  328.      (lap-inline ()
  329.        (:variable array address immediate?)
  330.        (move.l (varg array) atemp0)
  331.        (move.l (varg address) da)
  332.        (getint da)
  333.        (move.l (atemp0 da $v_data) arg_z)
  334.        (if# (ne (dtagp arg_z $t_fixnum $t_imm $t_sfloat))
  335.          (movereg arg_z acc)
  336.          (move.l '1 (varg immediate?))
  337.          else#
  338.          (jsr_subprim $sp-mkulong)))
  339.      immediate?)))
  340.  
  341. (defun (setf wood::read-pointer) (value disk-cache address &optional immediate?)
  342.   (unless (>= (wood::disk-cache-size disk-cache)
  343.               (+ address 4))
  344.     (wood::extend-disk-cache disk-cache (+ address 4)))
  345.   (multiple-value-bind (array index count)
  346.                        (wood::get-disk-page disk-cache address t)
  347.     (declare (fixnum index count))
  348.     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index))))
  349.       (error "Address odd or past eof: ~s" address))
  350.     (lap-inline ()
  351.       (:variable array index value immediate?)
  352.       (move.l (varg value) arg_z)
  353.       (if# (eq (cmp.l (varg immediate?) nilreg))
  354.         (jsr_subprim $sp-getxlong))
  355.       (move.l (varg array) atemp0)
  356.       (move.l (varg index) da)
  357.       (getint da)
  358.       (move.l acc (atemp0 da $v_data))))
  359.   value)
  360.  
  361. ; Store directly into a buffer.
  362. ; The buffer is assumed to be a byte array.
  363. ; If you store into a general array with this function,
  364. ; you will likely crash.
  365. (defun wood::%store-pointer (value array address &optional immediate?)
  366.   (ensure-byte-array array)
  367.   (setq address (require-type address 'fixnum))
  368.   (locally (declare (fixnum address))
  369.     (unless (>= (the fixnum (length array))
  370.                 (the fixnum (+ address 4)))
  371.       (error "Attempt to write past end of buffer."))
  372.     (unless (eql 0 (the fixnum (logand 1 address)))
  373.       (error "Odd address: ~s" address))
  374.     (lap-inline ()
  375.       (:variable array address value immediate?)
  376.         (move.l (varg value) arg_z)
  377.         (if# (eq (cmp.l (varg immediate?) nilreg))
  378.           (jsr_subprim $sp-getxlong))
  379.         (move.l (varg array) atemp0)
  380.         (move.l (varg address) da)
  381.         (getint da)
  382.         (move.l acc (atemp0 da $v_data))))
  383.   value)
  384.  
  385. ; Same as %store-pointer, but doesn't type check
  386. (defun wood::%%store-pointer (value array address &optional immediate?)
  387.   (lap-inline ()
  388.     (:variable array address value immediate?)
  389.     (move.l (varg value) arg_z)
  390.     (if# (eq (cmp.l (varg immediate?) nilreg))
  391.       (jsr_subprim $sp-getxlong))
  392.     (move.l (varg array) atemp0)
  393.     (move.l (varg address) da)
  394.     (getint da)
  395.     (move.l acc (atemp0 da $v_data))))
  396.  
  397. (defun wood::read-low-24-bits (disk-cache address)
  398.   (multiple-value-bind (array index count)
  399.                        (wood::get-disk-page disk-cache address)
  400.     (declare (fixnum index count))
  401.     (unless (>= count 4)
  402.       (error "Address past eof or not longword aligned: ~s" address))
  403.     (lap-inline ()
  404.       (:variable array index)
  405.       (move.l (varg array) atemp0)
  406.       (move.l (varg index) da)
  407.       (getint da)
  408.       (move.l (atemp0 da $v_data) acc)
  409.       (and.l ($ #xffffff) acc)
  410.       (mkint acc))))
  411.  
  412. (defun (setf wood::read-low-24-bits) (value disk-cache address)
  413.   (unless (>= (wood::disk-cache-size disk-cache)
  414.               (+ address 4))
  415.     (wood::extend-disk-cache disk-cache (+ address 4)))
  416.   (multiple-value-bind (array index count)
  417.                        (wood::get-disk-page disk-cache address t)
  418.     (declare (fixnum index count))
  419.     (unless (>= count 4)
  420.       (error "Address not longword aligned: ~s" address))
  421.     (lap-inline ()
  422.       (:variable array index value)
  423.       (move.l (varg value) arg_z)
  424.       (jsr_subprim $sp-getxlong)
  425.       (move.l (varg array) atemp0)
  426.       (move.l (varg index) da)
  427.       (getint da)
  428.       (lea (atemp0 da $v_data) atemp0)
  429.       (move.b @atemp0 db)
  430.       (move.l acc @atemp0)
  431.       (move.b db @atemp0)))
  432.   value)
  433.  
  434. ; Read an unsigned byte. Can't call it read-byte as Common Lisp
  435. ; already exports that symbol
  436. (defun wood::read-8-bits (disk-cache address)
  437.   (multiple-value-bind (array index count)
  438.                        (wood::get-disk-page disk-cache address)
  439.     (declare (fixnum index count))
  440.     (unless (>= count 1)
  441.       (error "Address past eof"))
  442.     (lap-inline ()
  443.       (:variable array index)
  444.       (move.l (varg array) atemp0)
  445.       (move.l (varg index) da)
  446.       (getint da)
  447.       (move.l ($ 0) acc)
  448.       (move.b (atemp0 da $v_data) acc)
  449.       (mkint acc))))
  450.  
  451. (defun wood::read-8-bits-signed (disk-cache address)
  452.   (multiple-value-bind (array index count)
  453.                        (wood::get-disk-page disk-cache address)
  454.     (declare (fixnum index count))
  455.     (unless (>= count 1)
  456.       (error "Address past eof"))
  457.     (lap-inline ()
  458.       (:variable array index)
  459.       (move.l (varg array) atemp0)
  460.       (move.l (varg index) da)
  461.       (getint da)
  462.       (move.b (atemp0 da $v_data) acc)
  463.       (ext.w acc)
  464.       (ext.l acc)
  465.       (mkint acc))))
  466.  
  467. (defun wood::%load-8-bits (array address)
  468.   (ensure-byte-array array)
  469.   (setq address (require-type address 'fixnum))
  470.   (locally (declare (fixnum address))
  471.     (unless (> (length array) address)
  472.       (error "attempt to read past end of buffer"))
  473.     (lap-inline ()
  474.       (:variable array address)
  475.       (move.l (varg array) atemp0)
  476.       (move.l (varg address) da)
  477.       (getint da)
  478.       (move.l ($ 0) acc)
  479.       (move.b (atemp0 da $v_data) acc)
  480.       (mkint acc))))
  481.  
  482. (defun (setf wood::read-8-bits) (value disk-cache address)
  483.   (unless (>= (wood::disk-cache-size disk-cache)
  484.               (+ address 4))
  485.     (wood::extend-disk-cache disk-cache (+ address 4)))
  486.   (multiple-value-bind (array index count)
  487.                        (wood::get-disk-page disk-cache address t)
  488.     (declare (fixnum index count))
  489.     (unless (>= count 4)
  490.       (error "Address not longword aligned: ~s" address))
  491.     (lap-inline ()
  492.       (:variable array index value)
  493.       (move.l (varg value) acc)
  494.       (getint acc)
  495.       (move.l (varg array) atemp0)
  496.       (move.l (varg index) da)
  497.       (getint da)
  498.       (move.b acc (atemp0 da $v_data))
  499.       (mkint acc))))
  500.  
  501. (defsetf wood::read-8-bits-signed (disk-cache address) (value)
  502.   `(setf (wood::read-8-bits ,disk-cache ,address) ,value))
  503.  
  504. (defun wood::%store-8-bits (value array address)
  505.   (ensure-byte-array array)
  506.   (setq address (require-type address 'fixnum))
  507.   (locally (declare (fixnum address))
  508.     (unless (> (length array) address)
  509.       (error "attempt to read past end of buffer"))
  510.     (lap-inline ()
  511.       (:variable value array address)
  512.       (move.l (varg value) acc)
  513.       (getint acc)
  514.       (move.l (varg array) atemp0)
  515.       (move.l (varg address) da)
  516.       (getint da)
  517.       (move.b acc (atemp0 da $v_data))
  518.       (mkint acc))))
  519.  
  520. ; These will get less ugly when we can stack cons float vectors
  521. (defun wood::read-double-float (disk-cache address)
  522.   (let ((vector (make-array 2 :element-type '(signed-byte 32))))
  523.     (declare (dynamic-extent vector))
  524.     (wood::load-byte-array disk-cache address 8 vector 0 t)
  525.     (ccl::%typed-uvref ccl::$v_floatv vector 0)))
  526.  
  527. (defun (setf wood::read-double-float) (value disk-cache address)
  528.   (let ((vector (make-array 2 :element-type '(signed-byte 32))))
  529.     (declare (dynamic-extent vector))
  530.     (ccl::%typed-uvset ccl::$v_floatv vector 0 value)
  531.     (wood::store-byte-array vector disk-cache address 8 0 t))
  532.   value)
  533.  
  534.  
  535. (defun wood::read-string (disk-cache address length &optional string)
  536.   (setq length (require-type length 'fixnum))
  537.   (locally (declare (fixnum length))
  538.     (when (> (+ address length) (wood::disk-cache-size disk-cache))
  539.       (error "Attempt to read past EOF"))
  540.     (let ((offset 0)
  541.           inner-string)
  542.       (declare (fixnum offset))
  543.       (if (and string
  544.                (progn
  545.                  (setq string (require-type string 'string))
  546.                  (array-has-fill-pointer-p string)))
  547.         (progn
  548.           (if (> length (array-total-size string))
  549.             (setq string (adjust-array string length))
  550.             (setf (fill-pointer string) length))
  551.           (multiple-value-setq (inner-string offset)
  552.             (array-data-and-offset string)))
  553.         (progn
  554.           (unless (>= (length string) length)
  555.             (error "~s is < ~s characters long" string length))
  556.         (setq inner-string string)))
  557.       (loop
  558.         (multiple-value-bind (array index count)
  559.                              (wood::get-disk-page disk-cache address)
  560.           (declare (fixnum count index))
  561.           (lap-inline ()
  562.             (:variable array index count length inner-string offset)
  563.             (move.l (varg array) atemp0)
  564.             (move.l (varg index) da)
  565.             (getint da)
  566.             (lea (atemp0 da $v_data) atemp0)
  567.             (move.l (varg inner-string) atemp1)
  568.             (move.l (varg offset) da)
  569.             (getint da)
  570.             (lea (atemp1 da.l $v_data) atemp1)
  571.             (move.l (varg length) da)
  572.             (if# (gt (cmp.l (varg count) da))
  573.               (move.l (varg count) da))
  574.             (getint da)
  575.             (dbfloop.l da
  576.                        (move.b atemp0@+ atemp1@+)))
  577.           (when (<= (decf length count) 0)
  578.             (return))
  579.           (incf address (the fixnum (+ count wood::$block-overhead)))
  580.           (incf offset count)))))
  581.   string)
  582.  
  583. ; Same as array-data-and-offset but works for
  584. ; non-array uvectors.
  585. (defun lenient-array-data-and-offset (array)
  586.   (if (eql $v_arrayh (%vect-subtype array))
  587.     (array-data-and-offset array)
  588.     (values array 0)))
  589.  
  590. (defun uvector-bytes (uvector)
  591.   (lap-inline (uvector)
  592.     (if# (eq (dtagp arg_z $t_vector))
  593.       (wtaerr arg_z 'uvector))
  594.     (move.l arg_z atemp0)
  595.     (vsize atemp0 arg_z)
  596.     (mkint arg_z)))
  597.  
  598. (defun wood::load-byte-array (disk-cache address length byte-array &optional
  599.                                          (start 0) trust-me?)
  600.   (setq length (require-type length 'fixnum))
  601.   (setq start (require-type start 'fixnum))
  602.   (locally (declare (fixnum length))
  603.     (when (> (+ address length) (wood::disk-cache-size disk-cache))
  604.       (error "Attempt to read past EOF"))
  605.     (multiple-value-bind (inner-array offset)
  606.                          (lenient-array-data-and-offset byte-array)
  607.       (unless trust-me?                 ; for p-load-ivector
  608.         (ensure-byte-array byte-array)
  609.         (if (> (+ start length) (uvector-bytes byte-array))
  610.           (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length))))
  611.       (incf offset start)
  612.       (loop
  613.         (multiple-value-bind (array index count)
  614.                              (wood::get-disk-page disk-cache address)
  615.           (declare (fixnum count index))
  616.           (lap-inline ()
  617.             (:variable array index count length inner-array offset)
  618.             (move.l (varg array) atemp0)
  619.             (move.l (varg index) da)
  620.             (getint da)
  621.             (lea (atemp0 da $v_data) atemp0)
  622.             (move.l (varg inner-array) atemp1)
  623.             (move.l (varg offset) da)
  624.             (getint da)
  625.             (lea (atemp1 da.l $v_data) atemp1)
  626.             (move.l (varg length) da)
  627.             (if# (gt (cmp.l (varg count) da))
  628.               (move.l (varg count) da))
  629.             (getint da)
  630.             (dbfloop.l da
  631.                        (move.b atemp0@+ atemp1@+)))
  632.           (when (<= (decf length count) 0)
  633.             (return))
  634.           (incf address (the fixnum (+ count wood::$block-overhead)))
  635.           (incf offset count)))))
  636.   byte-array)
  637.  
  638. ; Copy length bytes from from at from-index to to at to-index.
  639. ; from-index, length, and to-index must be fixnums
  640. ; if (eq from to), the copying will be done in the correct order.
  641. ; If either array is not a byte array or string, you will likely crash
  642. ; sometime in the future.
  643. (defun wood::%copy-byte-array-portion (from from-index length to to-index &optional to-page)
  644.   (declare (ignore to-page))            ; for logging/recovery
  645.   (setq from-index (require-type from-index 'fixnum))
  646.   (setq length (require-type length 'fixnum))
  647.   (setq to-index (require-type to-index 'fixnum))
  648.   (locally (declare (fixnum from-index length to-index))
  649.     (when (> length 0)
  650.       (unless (and (>= from-index 0)
  651.                    (<= (the fixnum (+ from-index length)) (uvector-bytes from))
  652.                    (>= to-index 0)
  653.                    (<= (the fixnum (+ to-index length)) (uvector-bytes to)))
  654.         (error "Attempt to index off end of one of the arrays"))
  655.       (multiple-value-bind (from off) (lenient-array-data-and-offset from)
  656.         (incf from-index off)
  657.         (multiple-value-bind (to off) (lenient-array-data-and-offset to)
  658.           (incf to-index off)
  659.           (ensure-byte-array from)
  660.           (ensure-byte-array to)
  661.           (lap-inline ()
  662.             (:variable from from-index length to to-index)
  663.             (move.l (varg from) atemp0)
  664.             (move.l atemp0 arg_x)             ; arg_x = from
  665.             (move.l (varg from-index) da)
  666.             (getint da)
  667.             (move.l da arg_y)                 ; arg_y = from-index
  668.             (lea (atemp0 da.l $v_data) atemp0)
  669.             (move.l (varg to) atemp1)
  670.             (move.l atemp1 arg_z)             ; arg_z = to
  671.             (move.l (varg to-index) da)
  672.             (getint da)
  673.             (move.l da db)                    ; db = to-index
  674.             (lea (atemp1 da.l $v_data) atemp1)
  675.             (move.l (varg length) da)
  676.             (getint da)
  677.             (if# (and (eq (cmp.l arg_x arg_z))
  678.                       (gt (cmp.l arg_y db)))
  679.               (add.l da atemp0)
  680.               (add.l da atemp1)
  681.               (dbfloop da
  682.                        (move.b -@atemp0 -@atemp1))
  683.               else#
  684.               (dbfloop da
  685.                        (move.b atemp0@+ atemp1@+))))))))
  686.   to)
  687.  
  688. (defun wood::%load-string (array index length &optional string)
  689.   (unless string
  690.     (setq string (make-string length)))
  691.   (wood::%copy-byte-array-portion array index length string 0))
  692.  
  693. (defun wood::%store-string (string array index &optional (length (length string)))
  694.   (wood::%copy-byte-array-portion string 0 length array index)
  695.   string)
  696.   
  697. (defun (setf wood::read-string) (string disk-cache address &optional length)
  698.   (if length
  699.     (when (> (setq length (require-type length 'fixnum)) (length string))
  700.       (error "~s > the length of the string." 'length))
  701.     (setq length (length string)))
  702.   (unless (>= (wood::disk-cache-size disk-cache)
  703.               (+ address length))
  704.     (wood::extend-disk-cache disk-cache (+ address length)))
  705.   (multiple-value-bind (string offset) (array-data-and-offset string)
  706.     (declare (fixnum offset))
  707.     (loop
  708.       (multiple-value-bind (array index count)
  709.                            (wood::get-disk-page disk-cache address t)
  710.         (declare (fixnum count index))
  711.         (lap-inline ()
  712.           (:variable array index count length string offset)
  713.           (move.l (varg array) atemp0)
  714.           (move.l (varg index) da)
  715.           (getint da)
  716.           (lea (atemp0 da $v_data) atemp0)
  717.           (move.l (varg string) atemp1)
  718.           (move.l (varg offset) da)
  719.           (getint da)
  720.           (lea (atemp1 da.l $v_data) atemp1)
  721.           (move.l (varg length) da)
  722.           (if# (gt (cmp.l (varg count) da))
  723.             (move.l (varg count) da))
  724.           (getint da)
  725.           (dbfloop.l da
  726.                      (move.b atemp1@+ atemp0@+)))
  727.         (when (<= (decf length count) 0)
  728.           (return))
  729.         (incf address (the fixnum (+ count wood::$block-overhead)))
  730.         (incf offset count))))
  731.   string)
  732.  
  733. (defun wood::store-byte-array (byte-array disk-cache address length &optional
  734.                                           (start 0) trust-me?)
  735.   (setq length (require-type length 'fixnum))
  736.   (setq start (require-type start 'fixnum))
  737.   (locally (declare (fixnum length))
  738.     (when (> (+ address length) (wood::disk-cache-size disk-cache))
  739.       (error "Attempt to read past EOF"))
  740.     (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset byte-array)
  741.       (unless trust-me?                 ; for p-load-ivector
  742.         (ensure-byte-array byte-array)
  743.         (if (> (+ start length) (uvector-bytes byte-array))
  744.           (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length))))
  745.       (incf offset start)
  746.       (loop
  747.         (multiple-value-bind (array index count)
  748.                              (wood::get-disk-page disk-cache address t)
  749.           (declare (fixnum count index))
  750.           (lap-inline ()
  751.             (:variable array index count length inner-array offset)
  752.             (move.l (varg array) atemp0)
  753.             (move.l (varg index) da)
  754.             (getint da)
  755.             (lea (atemp0 da $v_data) atemp0)
  756.             (move.l (varg inner-array) atemp1)
  757.             (move.l (varg offset) da)
  758.             (getint da)
  759.             (lea (atemp1 da.l $v_data) atemp1)
  760.             (move.l (varg length) da)
  761.             (if# (gt (cmp.l (varg count) da))
  762.               (move.l (varg count) da))
  763.             (getint da)
  764.             (dbfloop.l da
  765.                        (move.b atemp1@+ atemp0@+)))
  766.           (when (<= (decf length count) 0)
  767.             (return))
  768.           (incf address (the fixnum (+ count wood::$block-overhead)))
  769.           (incf offset count)))))
  770.   byte-array)
  771.  
  772. (defun wood::fill-long (disk-cache address value count &optional immediate?)
  773.   (let ((count (require-type count 'fixnum)))
  774.     (declare (fixnum count))
  775.     (unless (eql 0 (logand 1 address))
  776.       (error "Odd address: ~s" address))
  777.     (let ((min-size (+ address (ash count 2))))
  778.       (when (< (wood::disk-cache-size disk-cache) min-size)
  779.         (wood::extend-disk-cache disk-cache min-size)))
  780.     (loop
  781.       (multiple-value-bind (vector offset size)
  782.                            (wood::get-disk-page disk-cache address t)
  783.         (declare (fixnum offset size))
  784.         (when (<= size 0)
  785.           (error "attempt to write past end of ~s" disk-cache))
  786.         (let ((words (ash size -2)))
  787.           (declare (fixnum words))
  788.           (if (< count words) (setq words count))
  789.           (lap-inline ()
  790.             (:variable vector offset words value immediate?)
  791.             (move.l (varg value) arg_z)
  792.             (if# (eq (cmp.l (varg immediate?) nilreg))
  793.               (jsr_subprim $sp-getxlong)
  794.              else#
  795.               (movereg arg_z acc))
  796.             (move.l (varg vector) atemp0)
  797.             (move.l (varg offset) da)
  798.             (getint da)
  799.             (lea (atemp0 da $v_data) atemp0)
  800.             (move.l (varg words) da)
  801.             (getint da)
  802.             (dbfloop da (move.l acc atemp0@+)))
  803.           (if (<= (decf count words) 0) (return)))
  804.         (incf address (the fixnum (+ size wood::$block-overhead)))))))
  805.  
  806. (defun wood::fill-word (disk-cache address value count &optional immediate?)
  807.   (declare (ignore immediate?))
  808.   (let ((count (require-type count 'fixnum))
  809.         (address address)
  810.         (value (require-type value 'fixnum)))
  811.     (declare (fixnum count))
  812.     (unless (eql 0 (logand 1 address))
  813.       (error "Odd address: ~s" address))
  814.     (let ((min-size (+ address (ash count 1))))
  815.       (when (< (wood::disk-cache-size disk-cache) min-size)
  816.         (wood::extend-disk-cache disk-cache min-size)))
  817.     (loop
  818.       (multiple-value-bind (vector offset size)
  819.                            (wood::get-disk-page disk-cache address t)
  820.         (declare (fixnum offset size))
  821.         (when (<= size 0)
  822.           (error "attempt to write past end of ~s" disk-cache))
  823.         (let ((words (ash size -1)))
  824.           (declare (fixnum words))
  825.           (if (< count words) (setq words count))
  826.           (lap-inline ()
  827.             (:variable vector offset words value)
  828.             (move.l (varg vector) atemp0)
  829.             (move.l (varg offset) da)
  830.             (getint da)
  831.             (lea (atemp0 da.l $v_data) atemp0)
  832.             (move.l (varg words) da)
  833.             (getint da)
  834.             (move.l (varg value) acc)
  835.             (getint acc)
  836.             (dbfloop da (move.w acc atemp0@+)))
  837.           (if (<= (decf count words) 0) (return)))
  838.         (incf address (the fixnum (+ size wood::$block-overhead)))))))
  839.  
  840. (defun wood::fill-byte (disk-cache address value count &optional immediate?)
  841.   (declare (ignore immediate?))
  842.   (let ((count (require-type count 'fixnum))
  843.         (address address)
  844.         (value (require-type value 'fixnum)))
  845.     (declare (fixnum count))
  846.     (let ((min-size (+ address count)))
  847.       (when (< (wood::disk-cache-size disk-cache) min-size)
  848.         (wood::extend-disk-cache disk-cache min-size)))
  849.     (loop
  850.       (multiple-value-bind (vector offset size)
  851.                            (wood::get-disk-page disk-cache address t)
  852.         (declare (fixnum offset size))
  853.         (when (<= size 0)
  854.           (error "attempt to write past end of ~s" disk-cache))
  855.         (if (< count size) (setq size count))
  856.         (lap-inline ()
  857.           (:variable vector offset size value)
  858.           (move.l (varg vector) atemp0)
  859.           (move.l (varg offset) da)
  860.           (getint da)
  861.           (lea (atemp0 da $v_data) atemp0)
  862.           (move.l (varg size) da)
  863.           (getint da)
  864.           (move.l (varg value) acc)
  865.           (getint acc)
  866.           (dbfloop.l da (move.b acc atemp0@+)))
  867.         (if (<= (decf count size) 0) (return))
  868.         (incf address (the fixnum (+ size wood::$block-overhead)))))))
  869.  
  870. (defun wood::array-fill-long (array address value count &optional immediate?)
  871.   (ensure-byte-array array)
  872.   (let ((count (require-type count 'fixnum))
  873.         (address (require-type address 'fixnum))
  874.         (value (require-type value 'fixnum)))
  875.     (declare (fixnum count address))
  876.     (let ((min-size (+ address (* 4 count))))
  877.       (when (< (length array) min-size)
  878.         (error "Attempt to write past end of array")))
  879.     (unless (eql 0 (the fixnum (logand 1 address)))
  880.       (error "Odd address: ~s" address))
  881.     (lap-inline ()
  882.       (:variable array address value count immediate?)
  883.       (move.l (varg array) atemp0)
  884.       (move.l (varg value) acc)
  885.       (if# (eq (cmp.l (varg immediate?) nilreg))
  886.         (movereg acc arg_z)
  887.         (jsr_subprim $sp-getxlong))
  888.       (move.l (varg address) da)
  889.       (getint da)
  890.       (lea (atemp0 da $v_data) atemp0)
  891.       (move.l (varg count) da)
  892.       (dbfloop.l da (move.l acc atemp0@+))))
  893.   nil)
  894.  
  895. (defun wood::array-fill-word (array address value count)
  896.   (ensure-byte-array array)
  897.   (let ((count (require-type count 'fixnum))
  898.         (address (require-type address 'fixnum))
  899.         (value (require-type value 'fixnum)))
  900.     (declare (fixnum count address))
  901.     (let ((min-size (+ address (* 2 count))))
  902.       (when (< (length array) min-size)
  903.         (error "Attempt to write past end of array")))
  904.     (unless (eql 0 (the fixnum (logand 1 address)))
  905.       (error "Odd address: ~s" address))
  906.     (lap-inline ()
  907.       (:variable array address value count)
  908.       (move.l (varg array) atemp0)
  909.       (move.l (varg value) acc)
  910.       (getint acc)
  911.       (move.l (varg address) da)
  912.       (getint da)
  913.       (lea (atemp0 da $v_data) atemp0)
  914.       (move.l (varg count) da)
  915.       (dbfloop.l da (move.w acc atemp0@+))))
  916.   nil)
  917.  
  918. (defun wood::array-fill-byte (array address value count)
  919.   (ensure-byte-array array)
  920.   (let ((count (require-type count 'fixnum))
  921.         (address (require-type address 'fixnum))
  922.         (value (require-type value 'fixnum)))
  923.     (declare (fixnum count address))
  924.     (let ((min-size (+ address count)))
  925.       (when (< (length array) min-size)
  926.         (error "Attempt to write past end of array")))
  927.     (lap-inline ()
  928.       (:variable array address value count)
  929.       (move.l (varg array) atemp0)
  930.       (move.l (varg value) acc)
  931.       (getint acc)
  932.       (move.l (varg address) da)
  933.       (getint da)
  934.       (lea (atemp0 da $v_data) atemp0)
  935.       (move.l (varg count) da)
  936.       (getint da)
  937.       (dbfloop.l da (move.b acc atemp0@+))))
  938.   nil)
  939.   
  940.  
  941. ; some macros to make using this take less typing.
  942.  
  943. (in-package :wood)
  944.  
  945. (export '(accessing-disk-cache))
  946.  
  947. (defmacro accessing-disk-cache ((disk-cache &optional base) &body body)
  948.   (let* ((b (gensym)))
  949.     `(let ((-*dc*- ,disk-cache)
  950.            ,@(when base
  951.                `((,b ,base))))
  952.        (macrolet ((-*addr*- (address)
  953.                     (if ',base
  954.                       `(+ ,',b ,address)
  955.                       address))
  956.                   (-*select*- (operation disk-cache-code array-code)
  957.                     (declare (ignore array-code))
  958.                     (if (eq disk-cache-code :error)
  959.                       (error "~s not supported for disk-cache's" operation))
  960.                     disk-cache-code))
  961.          ,@body))))
  962.  
  963. (defmacro accessing-byte-array ((byte-array &optional base disk-page) &body body)
  964.   (let* ((b (gensym)))
  965.     `(let ((-*dc*- ,byte-array)
  966.            ,@(when base
  967.                `((,b ,base))))
  968.        (macrolet ((-*addr*- (address)
  969.                     (if ',base
  970.                       `(+ ,',b ,address)
  971.                       address))
  972.                   (-*select*- (operation disk-cache-code array-code)
  973.                     (declare (ignore disk-cache-code))
  974.                     (if (eq array-code :error)
  975.                       (error "~s not supported for arrays" operation))
  976.                     array-code))
  977.          ,disk-page
  978.          ,@body))))
  979.  
  980. (defun ensure-accessing-disk-cache (accessor env)
  981.   (unless (and (eq :lexical (variable-information '-*dc*- env))
  982.                (eq :macro (function-information '-*addr*- env))
  983.                (eq :macro (function-information '-*select*- env)))
  984.     (error "~s called ouside of ~s environment"
  985.            accessor 'accessing-disk-cache)))
  986.  
  987. (defmacro load.l (address &environment env)
  988.   (ensure-accessing-disk-cache 'load.l env)
  989.   `(-*select*-
  990.     load.l
  991.     (read-long -*dc*- (-*addr*- ,address))
  992.     (%load-long -*dc*- (-*addr*- ,address))))
  993.  
  994. (defmacro load.ul (address &environment env)
  995.   (ensure-accessing-disk-cache 'load.ul env)
  996.   `(-*select*-
  997.     load.ul
  998.     (read-unsigned-long -*dc*- (-*addr*- ,address))
  999.     (%load-unsigned-long -*dc*- (-*addr*- ,address))))
  1000.  
  1001. (defmacro load.p (address &environment env)
  1002.   (ensure-accessing-disk-cache 'load.ul env)
  1003.   `(-*select*-
  1004.     load.p
  1005.     (read-pointer -*dc*- (-*addr*- ,address))
  1006.     (%load-pointer -*dc*- (-*addr*- ,address))))
  1007.  
  1008. (defmacro load.w (address &environment env)
  1009.   (ensure-accessing-disk-cache 'load.w env)
  1010.   `(the fixnum
  1011.         (-*select*-
  1012.          load.w
  1013.          (read-word -*dc*- (-*addr*- ,address))
  1014.          (%load-word -*dc*- (-*addr*- ,address)))))
  1015.  
  1016. (defmacro load.uw (address &environment env)
  1017.   (ensure-accessing-disk-cache 'load.uw env)
  1018.   `(the fixnum
  1019.         (-*select*-
  1020.          load.uw
  1021.          (read-unsigned-word -*dc*- (-*addr*- ,address))
  1022.          (%load-unsigned-word -*dc*- (-*addr*- ,address)))))
  1023.  
  1024. (defmacro load.b (address &environment env)
  1025.   (ensure-accessing-disk-cache 'load.b env)
  1026.   `(the fixnum
  1027.         (-*select*-
  1028.          load.b
  1029.          (read-8-bits -*dc*- (-*addr*- ,address))
  1030.          (%load-8-bits -*dc*- (-*addr*- ,address)))))
  1031.  
  1032. (defmacro load.string (address length &optional string &environment env)
  1033.   (ensure-accessing-disk-cache 'load.string env)
  1034.   `(-*select*-
  1035.     load.string
  1036.     (read-string -*dc*- (-*addr*- ,address) ,length
  1037.                  ,@(if string `(,string)))
  1038.     (%load-string -*dc*- (-*addr*- ,address) ,length
  1039.                  ,@(if string `(,string)))))
  1040.  
  1041. (defmacro store.l (value address &environment env)
  1042.   (ensure-accessing-disk-cache 'store.l env)
  1043.   `(-*select*-
  1044.     store.l
  1045.     (let ((-*temp*- ,value))
  1046.       (setf (read-long -*dc*- (-*addr*- ,address)) -*temp*-))
  1047.     (%store-long ,value -*dc*- (-*addr*- ,address))))
  1048.  
  1049. (defmacro store.p (value address &optional value-imm? &environment env)
  1050.   (ensure-accessing-disk-cache 'store.p env)
  1051.   `(-*select*-
  1052.     store.p
  1053.     (let ((-*temp*- ,value))
  1054.       (setf (read-pointer -*dc*- (-*addr*- ,address)
  1055.                           ,@(if value-imm? `(,value-imm?)))
  1056.             -*temp*-))
  1057.     (%store-pointer ,value -*dc*- (-*addr*- ,address)
  1058.                     ,@(if value-imm? `(,value-imm?)))))
  1059.  
  1060. (defmacro store.w (value address &environment env)
  1061.   (ensure-accessing-disk-cache 'store.w env)
  1062.   `(-*select*-
  1063.     store.w
  1064.     (let ((-*temp*- ,value))
  1065.       (setf (read-word -*dc*- (-*addr*- ,address)) -*temp*-))
  1066.     (%store-word ,value -*dc*- (-*addr*- ,address))))
  1067.  
  1068. (defmacro store.b (value address &environment env)
  1069.   (ensure-accessing-disk-cache 'store.b env)
  1070.   `(-*select*-
  1071.     store.b
  1072.     (let ((-*temp*- ,value))
  1073.       (setf (read-8-bits -*dc*- (-*addr*- ,address)) -*temp*-))
  1074.     (%store-8-bits ,value -*dc*- (-*addr*- ,address))))
  1075.  
  1076. (defmacro store.string (string address &optional length &environment env)
  1077.   (ensure-accessing-disk-cache 'store.string env)
  1078.   `(-*select*-
  1079.     store.string
  1080.     (funcall #'(setf read-string)
  1081.              ,string -*dc*- (-*addr*- ,address)
  1082.              ,@(if length `(,length)))
  1083.     (%store-string ,string -*dc*- (-*addr*- ,address)
  1084.              ,@(if length `(,length)))))
  1085.  
  1086. (defmacro fill.l (address value count &optional imm? &environment env)
  1087.   (ensure-accessing-disk-cache 'fill.l env)
  1088.   `(-*select*-
  1089.     fill.l
  1090.     (fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)
  1091.     (array-fill-long -*dc*- (-*addr*- ,address) ,value ,count ,imm?)))
  1092.  
  1093. (defmacro fill.w (address value count &environment env)
  1094.   (ensure-accessing-disk-cache 'fill.w env)
  1095.   `(-*select*-
  1096.     fill.w
  1097.     (fill-word -*dc*- (-*addr*- ,address) ,value ,count)
  1098.     (array-fill-word -*dc*- (-*addr*- ,address) ,value ,count)))
  1099.  
  1100. (defmacro fill.b (address value count &environment env)
  1101.   (ensure-accessing-disk-cache 'fill.b env)
  1102.   `(-*select*-
  1103.     fill.b
  1104.     (fill-byte -*dc*- (-*addr*- ,address) ,value ,count)
  1105.     (array-fill-byte -*dc*- (-*addr*- ,address) ,value ,count)))
  1106.  
  1107. (defmacro svref.p (vector index &environment env)
  1108.   (ensure-accessing-disk-cache 'svref.p env)
  1109.   `(-*select*-
  1110.     svref.p
  1111.     (dc-%svref -*dc*- ,vector ,index)
  1112.     :error))
  1113.  
  1114. (defmacro svset.p (vector index value &optional immediate? &environment env)
  1115.   (ensure-accessing-disk-cache 'svset.p env)
  1116.   `(-*select*-
  1117.     svset.p
  1118.     (setf (dc-%svref -*dc*- ,vector ,index ,@(if immediate? `(,immediate?)))
  1119.           ,value)
  1120.     :error))
  1121.  
  1122. (defmacro %vector-size.p (vector &environment env)
  1123.   (ensure-accessing-disk-cache '%vector-size.p env)
  1124.   `(-*select*-
  1125.     %vector-size.p
  1126.     (dc-%vector-size -*dc*- ,vector)
  1127.     :error))
  1128.                   
  1129.  
  1130. #|
  1131. (setq wood::dc (wood::open-disk-cache "temp.dc" 
  1132.                                       :if-exists :overwrite
  1133.                                       :if-does-not-exist :create))
  1134.  
  1135. (defun wood::wi (&optional (count 100000))
  1136.   (declare (special wood::dc))
  1137.   (let ((index 0))
  1138.     (declare (fixnum index))
  1139.     (dotimes (i count)
  1140.       (setf (wood::read-long wood::dc index) i)
  1141.       (incf index 4))))
  1142.  
  1143. (defun wood::ri (&optional (count 100000))
  1144.   (declare (special wood::dc))
  1145.   (let ((index 0))
  1146.     (declare (fixnum index))
  1147.     (dotimes (i count)
  1148.       (let ((was (wood::read-long wood::dc index)))
  1149.         (incf index 4)
  1150.         (unless (eql i was)
  1151.           (cerror "continue" "SB: ~d, Was: ~d" i was))))))
  1152.  
  1153. (require :lapmacros)
  1154.  
  1155. (defun wood::time-moves (&optional (count 100))
  1156.   (setq count (require-type count 'fixnum))
  1157.   (macrolet ((moves (count)
  1158.                `(lap-inline (,count)
  1159.                   (getint arg_z)
  1160.                   (move.l ($ 0) atemp0)
  1161.                   (dbfloop arg_z
  1162.                            ,@(make-list 1000 
  1163.                                         :initial-element
  1164.                                         '(move.l atemp0@+ da))))))
  1165.     (moves count)
  1166.     (* count 1000)))
  1167.             
  1168.  
  1169. ; Timing on a mac IIfx running System 7.0.
  1170. ;
  1171. ; (wi) first time:   2080 usec/long  (file allocation)
  1172. ; (wi) second time:   372 usec/long  (read every block. write half of them)
  1173. ; (ri) first time:    200 usec/long  (read every block. write half of them)
  1174. ; (ri) second time:   144 usec/long  (read every block)
  1175. ; (ri 20000) 2nd time: 66 usec/long  (no disk I/O)
  1176. ; (time-moves):       270 nanoseconds/long
  1177.  
  1178. (defun wood::ws (&optional (count most-positive-fixnum) (package :ccl))
  1179.   (declare (special wood::dc))
  1180.   (let ((address 0))
  1181.     (do-symbols (sym package)
  1182.       (let* ((name (symbol-name sym))
  1183.              (length (length name))
  1184.              (rounded-length (logand -4 (+ length 3))))
  1185.         (setf (wood::read-long wood::dc address) (length name))
  1186.         (incf address 4)
  1187.         (setf (wood::read-string wood::dc address) name)
  1188.         (incf address rounded-length)
  1189.         (if (<= (decf count) 0) (return))))
  1190.     (setf (wood::read-long wood::dc address) 0)
  1191.     address))
  1192.  
  1193. (defun wood::rs ()
  1194.   (declare (special wood::dc))
  1195.   (let ((address 0)
  1196.         (string (make-array 50 :fill-pointer t :adjustable t
  1197.                             :element-type 'character)))
  1198.     (loop
  1199.       (let ((length (wood::read-long wood::dc address)))
  1200.         (if (eql length 0) (return))
  1201.         (incf address 4)
  1202.         (print (wood::read-string wood::dc address length string))
  1203.         (incf address (logand -4 (+ length 3)))))))
  1204.     
  1205.   
  1206. |#
  1207.